--- Enter @derive@ and @instance@ definitions
module frege.compiler.passes.Instances where

-- import  Data.TreeMap as TM(TreeMap, each, keys, values, insert)
import  Data.List  as  DL(uniqBy, sort, sortBy)
import  frege.lib.PP(text, msgdoc)
import Control.monad.State

-- import  Compiler.enums.Flags  as  Compilerflags(TRACE3, TRACE4)
import  Compiler.enums.TokenID
import  Compiler.enums.Visibility
import  Compiler.enums.Literals
import  Compiler.enums.CaseKind

import  Compiler.types.Positions
import  Compiler.types.Tokens
-- import  Compiler.types.NSNames
import  Compiler.types.SNames
import  Compiler.types.Packs
import  Compiler.types.QNames
import  Compiler.types.Types
import  Compiler.types.SourceDefinitions
import  Compiler.types.Symbols
import  Compiler.types.Global  as  G
import  Compiler.types.ConstructorField
import  Compiler.types.AbstractJava(rawName)

import  Compiler.common.Errors  as  E()
import  Compiler.common.Resolve  as  R(defaultXName)
-- import  Compiler.common.SymbolTable  as  ST(linkq)
import  Compiler.classes.Nice

import  frege.compiler.Utilities  as  U(vSym)
import  frege.compiler.passes.Enter(enter, isInstOrDerive)
import  frege.compiler.gen.java.Common(sigmaJT)

-- import Ide.Utilities(label)
import  Compiler.common.Types as T
import Compiler.enums.Flags
verbose :: Global -> SigmaT QName -> String
verbose g t
    | otherwise    = t.rho.nicer g
label ∷ Global → SymbolT a → String
label g SymI{clas,typ} = nicer (instanceHead clas typ.rho) g
                            -- ++ " " ++ clas.nicer g ++ "  "   ++ verbose g typ
label g SymV{name,typ} = name.base    ++ dcolon g ++ verbose g typ 
label g SymD{name,typ} = name.base    ++ dcolon g ++ verbose g typ
label g SymC{name,tau} = name.base    ++ dcolon g ++ show tau.kind
label g SymT{name, nativ = Just n, pur}
    | pur       = name.base ++ dcolon g ++ "immutable native " ++ n
    | otherwise = name.base ++ dcolon g ++ "mutable native " ++ n            
label g SymA{name,typ} = name.base    ++ " = " ++ typ.rho.nicer gspecial
    where 
        gspecial = g.{options <- _.{flags <- Flags.flagSet SPECIAL}}   
label g sym
    | sym.{kind?}      = sym.name.base ++ dcolon g ++ show sym.kind
    | otherwise        = sym.name.base 
                    
dcolon _ = "::"


{--
    'pass' must be called only after type aliases have been resolved and all
    class and data definitions are entered.
 -}
pass () = do
    g <- getST
    let insdrv = filter isInstOrDerive g.sub.sourcedefs
        normal = filter (not • isInstOrDerive) g.sub.sourcedefs
    derived <- mapSt deriveInst insdrv
    enter (VName g.thisPack) derived
    -- change state so that derived instances will be transdef'ed later
    changeST Global.{sub <- SubSt.{sourcedefs = normal ++ derived}}
    stio ("instances", length derived)

--- make an instance definition from a derive definition, identity for instance definitions
deriveInst :: DefinitionS -> StG DefinitionS
deriveInst (d@InsDcl {pos}) = return d
deriveInst (d@DrvDcl {pos}) = do
        g <- getST
        clas <- defaultXName pos (TName pPreludeBase "Eq") d.clas
        typ  <- U.transSigma d.typ
        case instTSym typ g of
            Just (sym@SymT {env}) 
                                  | ctrs <- U.envConstructors env,
                                    not (null ctrs)
                                    || inPrelude clas.pack g && clas.base == "ArrayElement" 
                                    || inPrelude clas.pack g && clas.base == "JavaType" 
                                    || inPrelude clas.pack g && clas.base == "Exceptional" -> do
                dcls <- deriveDcls pos clas sym ctrs d.typ.rho
                -- dtyp <- withDerivedContext pos d.typ d.clas
                return idcl.{defs=dcls, typ=withDerivedContext pos d.typ d.clas clas}
            Just sym -> do
                E.error pos (msgdoc ("Can't derive " ++  clas.nice g
                             ++ " (" ++ typ.nice g ++ "), type has no constructors"))
                stio idcl
            Nothing ->  do
                E.error pos (msgdoc ("Can't derive " ++  clas.nice g
                             ++ " (" ++ typ.nice g ++ ")"))
                stio idcl
    where
        idcl = InsDcl {pos=d.pos, vis=d.vis, clas=d.clas,
                       typ=d.typ, doc=d.doc, defs=[]}
        withDerivedContext pos (ForAll [] rho) klasse qname
            | TName ppp base <- qname, 
              base `notElem` derivable = ForAll [] rho
            | null rho.context = ForAll [] rho.{context}
            where
                context = [ Ctx pos klasse (TVar pos KVar v) | v <- U.freeTVnames [] rho ]
        withDerivedContext pos sigma _ _ = sigma

deriveInst d = do
    E.fatal d.pos (text ("deriveInst got definition with constructor "
                    ++ show (constructor d)))

--- List of derivable classes
--- Note that special classes like 'Exceptional' and 'JavaType' are not listed here.
--- This controls also whether type variables in the instance type must have the same class membership.
derivable = ["Hashable", "Eq", "Ord", "Enum", "Bounded", "Show", "Exceptional", "FromJSON", "ToJSON"]

--- arity of a constructor
arity ∷ Symbol → Int
arity sym = length (Symbol.flds sym)

deriveClass :: Position → QName → Symbol → [Symbol] → RhoT SName -> Global → String → [DefinitionS]
deriveClass pos clas forty ctrs instrho g toderive = deriveClass toderive
    where
        con = head ctrs
        isEnum ∷ Bool
        isEnum = all (0==) (map arity ctrs)
        -- displayed name of a constructor
        cname ∷ Symbol → SName
        cname sym = case Symbol.name sym of
            MName tn base -> With1 pos.first.{tokid=CONID, value=tn.base}
                                   pos.first.{tokid=CONID, value=base}
            _ -> error "constructor must be a member"
        -- [PVar c1, PVar c2, PVar c3, ...]
        -- subpats "_" = repeat (pvar "_")
        subpats c = subvars c   -- [ var  (c ++ show a) | a <- enumFromTo 1 1000 ]
        subvars c = [ var  (c ++ show a) | a <- enumFromTo 1 1000 ]
        -- construct pattern  Con s1 s2 s3 ... sn
        conpat :: Symbol -> String -> ExprS
        conpat con s = Term app -- PCon {qname=cname con, pos=pos.change QCONID con.name.base, pats}
            where
                app  = fold App Con{name=cname con} pats 
                pats = take (arity con) (subpats s)
        -- construct simple (pattern) variables
        
        var :: String -> ExprS
        var  s = Vbl  {name=Simple pos.first.{tokid=VARID, value=s}}
        gvar p s = Vbl {name=With1 pos.first.{tokid=CONID, value=p} pos.first.{tokid=VARID, value=s}}
        gvar2 p t s = Vbl {name=With2 pos.first.{tokid=CONID, value=p}
                                      pos.first.{tokid=CONID, value=t}
                                      pos.first.{tokid=VARID, value=s}}
        !varg1  = var  "arg1"
        !varg2  = var  "arg2"
        !varg3  = var  "arg3"
        
        !parg1  = var "arg1"
        !parg2  = var "arg2"
        !parg3  = var "arg3"
        
        vOrd    = var "ord"
        vFrom   = var "from"
        baseToken = baseTokenAt pos.first
        -- misc global SNames
        tuple2Name  = With1 baseToken pos.first.{tokid=CONID, value="(,)"}
        consName    = With1 baseToken pos.first.{tokid=CONID, value=":"}
        nilName     = With1 baseToken pos.first.{tokid=CONID, value="[]"}
        eqName      = With2 baseToken pos.first.{tokid=CONID, value="Ordering"} pos.first.{tokid=CONID, value="Eq"}
        eqeqName    = With2 baseToken pos.first.{tokid=CONID, value="Eq"} pos.first.{tokid=VARID, value="=="}
        lteqName    = Simple pos.first.{tokid=VARID, value="<"}
        hashName    = With2 baseToken pos.first.{tokid=CONID, value="Eq"} pos.first.{tokid=VARID, value="hashCode"}
        addName     = With2 baseToken pos.first.{tokid=CONID, value="Int"} pos.first.{tokid=VARID, value="+"}
        mulName     = With2 baseToken pos.first.{tokid=CONID, value="Int"} pos.first.{tokid=VARID, value="*"}
        -- undefName   = With1 baseToken pos.first.{tokid=VARID, value="undefined"}
        errorName   = With1 baseToken pos.first.{tokid=VARID, value="error"}
        mapName     = With1 listToken pos.first.{tokid=VARID, value="map"}
        intEnumFTTName = With2 baseToken pos.first.{tokid=CONID, value="Int"} pos.first.{tokid=VARID, value="enumFromThenTo"}
        appName     = With2 baseToken pos.first.{tokid=CONID, value="String"} pos.first.{tokid=VARID, value="++"}
        showName    = With1 pos.first.{tokid=CONID, value="PreludeText"} pos.first.{tokid=VARID, value="show"}
        ptcon pats  = Term (fold App vtcon pats)
        !vtcon      = Con  {name= tuple2Name}
        ptup a b = ptcon [a,b]
        vtup a b = nApp  (nApp  vtcon a) b
        -- lists
        consCon = Con {name = consName}
        nilCon  = Con {name = nilName}
        cons a b = nApp (nApp consCon a) b
        singleton x = nApp (nApp consCon x) nilCon 
        -- misc constructors and vars
        !vEq = Con  {name=eqName}
        !vFalse = Lit {kind=LBool, value="false", pos, negated=false}
        !vTrue  = Lit {kind=LBool, value="true",  pos, negated=false}
        -- !vUndef = Vbl {name=undefName, pos=pos.change VARID "undefined", typ = Nothing}
        !vError = Vbl {name=errorName}
        !vMap   = Vbl {name=mapName}
        !vIntEnumFTT = Vbl {name=intEnumFTTName}
        !vApp   = Vbl {name=appName}
        !vShow  = Vbl {name=showName}
        !opEq   = Vbl {name=eqeqName}
        !opLt   = Vbl {name=lteqName}
        !opHash = Vbl {name=hashName}
        !opAdd  = Vbl {name=addName}
        !opMul  = Vbl {name=mulName}
        string s = Lit {kind=LString, value=show s,  pos=pos.change STRCONST (show s), negated=false}
        int :: Int -> ExprS
        int n    = Lit  {kind=LInt, value=n.abs.show, pos=pos.change INTCONST (show n), negated = n<0}
        -- make a function definition
        publicfun name pats expr = FunDcl {vis=Public, 
                                        positions = [pos.first], 
                                        lhs = var name, pats, expr,
                                        doc=Just "Function generated for derived instance."}
        calt p x  = CAlt {pat=p, ex=x}
        -- construct  a ++ b
        mkapp a b = nApp (nApp vApp a) b
        -- construct  a `op` b
        mkop a op b = nApp (nApp op a) b
        -- construct "show v"
        showit v = vShow `nApp` v
        -- type constructor for 'Class'
        pClass = TCon{pos, name = With1 baseToken pos.first.{tokid=CONID, value="Class"}}
        hash  = Case CNormal varg1 halts
        halts = map hashalt ctrs
        hashalt con = calt p hashex
                where
                    a = arity con
                    p = conpat con "a"
                    vs = take a (subvars "a")
                    c = nApp (gvar "PreludeBase" "constructor") varg1
                    hs = map (nApp opHash) vs
                    hfun a b = mkop (mkop (int 31) opMul a) opAdd b
                    hashex = fold hfun (int 1) (c:hs)  
        -- say if there is a constructor field without a name
        isPositionalCtor n
          | length n == 0 -> True
          | otherwise     ->  any (\f -> f.name == Nothing) n

        -- derive Hashable
        deriveClass "Hashable" = [publicfun "hashCode" [parg1] hash]
        -- derive ToJSON
        deriveClass "ToJSON"   = [publicfun "toJSON"   [parg1] toJson] where
          toJson = Case CNormal varg1 (ctrCaseAlts ctrs)
          ctrCaseAlts (c:[]) = [toJSONForCtr c []] where 
          ctrCaseAlts ctrs = map (\c -> toJSONForCtr c [addCase c]) ctrs where
            -- adds the required `case` field if the data type has multiple ctors
            addCase c = nApp (nApp vtcon (string "case")) (nApp toJSON (string c.name.base))
          toJSONForCtr :: Symbol -> [ExprS] -> CAltS
          toJSONForCtr (ctr@(SymD{flds, name, typ})) staticFields = 
            calt (matchOnFields flds) (serializeCtorFields flds staticFields) where
            matchOnFields flds = fields flds where
              fields []     = Con { name = ctrSName ctr}
              fields (a:as) = nApp (fields as) (varName as)
              -- We match on each field of the ctor and use the names f0 .. fn 
              -- to access the fields later on
              varName = var . ((++) "f") . show . length
              ctrSName ctr = Simple pos.first.{tokid=CONID, value = ctr.name.base}
            struct = gvar "JSON" "Struct"
            array  = gvar "JSON" "Array"
            serializeCtorFields flds staticFields = nApp struct $ 
              foldr toAstList (serializeCtorFields' flds) staticFields where
                serializeCtorFields' flds 
                  | isPositionalCtor flds -> serializeNonRecord flds 
                  | otherwise             -> serializeRecord flds
                toAstList = nApp . nApp consCon
            serializeNonRecord flds = singleton (nApp (nApp vtcon (string name.base)) (fields (length flds))) where
              fields 0 = gvar "JSON" "Null" -- ctor with no fields must be serialized as `null`
              fields _ = nApp array fieldArray
              fieldArray = go 0 where
                go nr | nr == (length flds) = nilCon
                      | otherwise = cons (nApp toJSON (varName nr)) (go (nr + 1))
            serializeRecord = go 0 where
              go _ []  = nilCon
              go nr (f:fs) = cons (tpl f (varName nr)) (go (nr + 1) fs)
            -- the number lets us access the single fields we previously matched on
            varName nr = var $ "f" ++ show nr
            tpl f variable =  nApp (nApp vtcon (string (fieldName f))) (nApp toJSON variable)
            fieldName :: ConField QName -> String
            fieldName f = case f.name of
              Nothing     -> error "Illegal state: at this position we already know that every field has a name"
              (Just name) -> name
          toJSONForCtr noCtor _ = error "Illegal state: At this position it can only be a ctor"
          toJSON = gvar "JSON" "toJSON"
        -- derive FromJSON
        deriveClass "FromJSON" = [publicfun "fromJSON" [parg1] fromJson] where
          fromJson = if length ctrs == 1 then singleCtor (head ctrs) else multipleCtors
          -- if a type as multiple ctor, it is discriminated by a field `case` with the ctor name as value
          multipleCtors = Case CNormal varg1 (lookForCaseField ctrs) where
            lookForCaseField ctrs = [ctorCase ctrs, cErr] 
            ctorCase ctrs = calt matchStruct lookForCase
            lookForCase = nApp (nApp flatMap (fieldInStruct "case")) (lam parg2 (findCtor ctrs))
            fieldInStruct name = (nApp (nApp field (string name)) (var "as"))
            findCtor ctrs = Case CNormal varg2 ((alts ctrs) ++ [cErr])
            -- handles: `{ "case": "CtorName" }`
            alts ctrs = map (\(name, ctr) -> calt (string name) (singleCtor ctr)) (zipped ctrs)
            zipped    = map (\ctr -> (ctr.name.key, ctr))
          lam pat expr = Lam pat expr False
          singleCtor ctr = Case CNormal varg1 (alts ctr)
          alts ctr = [cStruct ctr, cErr]
          cStruct :: Symbol -> CAltS
          cStruct (ctr@(SymD{flds, name, typ})) = calt matchStruct (exprFields flds ctr)
          cStruct noCtor = error "Illegal state: At this position it can only be a ctor"
          exprFields :: [ConField QName] -> Symbol -> ExprS
          -- if there is a field without a name we are working with a ctr which 
          -- does not use record syntax, thus we need to handle the JSON differently
          exprFields fields ctr = 
            if isPositionalCtor fields then 
              handleNonRecord (length fields) ctr
            else
              handleRecord fields ctr 
          handleNonRecord 0 ctr = nApp pure' (con ctr) -- Infx fmap.name (con ctr) (requiredField (string ctr.name.key))
          handleNonRecord 1 ctr = Infx fmap.name (con ctr) (requiredField (string ctr.name.key))
          handleNonRecord n ctr = Infx flatMap.name (requiredField (string ctr.name.key)) (lam parg2 (handleArr n ctr)) 
            where
              handleArr fieldCount ctr = Case CNormal varg2 ([cArray, cErr])
              cArray = calt matchArray (app n)
              matchArray = nApp Con { name = arraySName } (var "flds") 
              arraySName = With1 pos.first.{ tokid=CONID, value="JSON" } pos.first.{tokid=CONID, value="Array"}
              -- from here on we work with a tuple to use a state: (ctorToApply, listOfRemainingValues) 
              -- the first element will finally contain the finished value
              app n = Infx flatMap.name parseFirst (parseRest n) where
                parseFirst = updateState (con ctr) (var "flds") (parseHead (var "flds"))
                -- At this position we know, that there *must* be at least 2 fields for the ctor
                -- For convenience reasons we make heavy use of shadowing (parsed & tpl). This lets us reuse functions way more easy
                parseRest n | n > 2  = (lam tpl (Infx flatMap.name (updateState firstTplEl secondTplEl (parseHead secondTplEl)) (parseRest (n - 1))))
                            | otherwise = parseLast
                parseLast = (lam tpl (Infx fmap.name firstTplEl (parseHead secondTplEl)))
                parseHead (list :: ExprS) = nApp fromJSON (nApp head' list)
                updateState ctr state = Infx fmap.name (lam (var "parsed") createTuple) where
                  createTuple = (vtup (nApp ctr (var "parsed")) (nApp tail' state))
                secondTplEl = (nApp snd' tpl)
                firstTplEl  = (nApp fst' tpl)
                tpl         = (var "tpl")
          requiredField fieldName = (nApp (nApp field fieldName) (var "as"))
          handleRecord :: [ConField QName] -> Symbol -> ExprS
          handleRecord fields ctr = appFields (reverse fields) where
            appFields :: [ConField QName] -> ExprS
            appFields []         = con ctr -- if we have no fields in the CTOR, we have nothing to do
            appFields (f:[])     = Infx fmap.name (con ctr) (singleField f)
            appFields (f:fields) = Infx app.name (appFields fields) (singleField f)
            -- parses a single required or optional field
            singleField :: ConField QName -> ExprS
            singleField field 
              | isRequiredType field.typ.rho -> requiredField name
              | otherwise                    -> optionalField name
                where 
                -- A RhoFun only appears if one derives for a data decl with a 
                -- function field type. A function is always required (otherwise 
                -- it wouldn't be a RhoFun but a RhoTau.)
                isRequiredType (RhoFun _ _ _) = True
                isRequiredType (RhoTau _ tau) = case tau of
                  -- Tau is a Meta? 
                  -- -> type for this field field is not known yet, we need to 
                  -- search the AST, and then check by that if it is required
                  (Meta _) -> isRequiredType typeInAst
                    where 
                      typeInAst     = sigma.rho
                      (sigma, _)      = State.run qualifiedSigma g 
                      qualifiedSigma  = U.transSigma unqualifiedType
                      unqualifiedType = getTypeFromAst forty ctr field g.sub.sourcedefs
                      -- The field in question is qualified by the ctr it 
                      -- belongs to which is then qualified by the data decl 
                      -- it belongs to. 
                      getTypeFromAst :: Symbol -> Symbol -> ConField QName -> [DefinitionS] -> SigmaS
                      getTypeFromAst (SymT{name=dataName}) (SymD{name=ctrName}) conField defs = head 
                        [ typ | d@(DatDcl _ _ dName _ _ _ _ _) <- defs -- only keep data declarations
                        , ctr@(DCon _ _ cName _ _) <- d.ctrs           -- in each data decl , find the ctrs
                        , (Field _ (Just fName) _ _ _ typ) <- ctr.flds -- in each ctr find the fields
                        , dName == dataName.base &&                    -- only keep the data decl containing the correct ctr
                          cName == ctrName.base &&                     -- only keep the ctr containing the field in question
                          fName == fieldName conField                  -- only keep the field with the name in question
                        ]
                      getTypeFromAst _ _ _ _ = error "Illegal state: at this position these constructors are not possible"
                  -- type information is already available
                  _ -> not . isMaybeType $ tau
                    where 
                      isMaybeType :: Tau -> Bool
                      isMaybeType (TCon{name}) = name.base == "Maybe"
                      isMaybeType (TApp  tau _ ) = isMaybeType tau
                      isMaybeType _ = False
                optionalField :: ExprS  -> ExprS
                optionalField fieldName = (nApp (nApp optField fieldName) (var "as"))
                name = string . fieldName $ field
                fieldName :: ConField QName -> String
                fieldName f = case f.name of
                  Nothing     -> error "Illegal state: at this position we already know that every field has a name"
                  (Just name) -> name
          con ctr = Con { name = cname ctr }
          field = gvar "JSON" "field"
          fst' = var "fst"
          snd' = var "snd"
          optField = gvar "JSON" "optional"
          fromJSON = gvar "JSON" "fromJSON"
          head' = gvar "PreludeList" "head"
          tail' = gvar "PreludeList" "tail"
          flatMap = gvar2 "PreludeMonad" "Bind" ">>="
          fmap = gvar "PreludeMonad" "<$>"
          pure' = gvar "PreludeMonad" "pure"
          app = gvar2 "PreludeMonad" "Apply" "<*>"
          matchStruct = nApp Con { name=structSName } (var "as") 
          structSName = With1 pos.first.{tokid=CONID, value="JSON"} pos.first.{tokid=CONID, value="Struct"}
          cErr   = calt (var "garbage") (nApp opFail errMsg)
          errMsg = nApp (nApp vApp (string $ "Couldn't decode " ++ forty.nicer g ++ " from: ")) showGarbage
          showGarbage = nApp vShow (var "garbage")
          opFail = gvar2 "PreludeMonad" "MonadFail" "fail"
        -- derive Eq
        deriveClass "Eq" = [publicfun "==" [parg1,parg2] ifx, publicfun "hashCode" [parg1] hash] where
            ifx   = if length ctrs == 1 then eex else Ifte cond eex vFalse
            eex   = if isEnum then vTrue else Case CNormal (vtup varg1 varg2) alts
            alts  = map mkequalalt ctrs ++ deflt
            deflt = if length ctrs == 1 then [] else [dalt]
            dalt  = calt (var "_") vFalse
            cond  = nApp  (nApp opEq ca1) ca2
            ca1   = nApp (gvar "PreludeBase" "constructor") varg1
            ca2   = nApp (gvar "PreludeBase" "constructor") varg2
            -- (C,C) -> true, (C1 a1 a2, C1 b1 b2) -> a1 == b1 && a2==b2
            mkequalalt con = calt (ptup peq1 peq2) eqex
                where
                    a = arity con
                    peq1 = conpat con "a"
                    peq2 = conpat con "b"
                    sub1 = take a (subvars "a")
                    sub2 = take a (subvars "b")
                    eqex = andit (map eqit (zip sub1 sub2))
                    eqit (a,b) = nApp (nApp opEq a) b
                    andit [] = vTrue
                    andit [x] = x
                    andit (x:xs) = nApp (nApp (gvar "PreludeBase" "&&") x) (andit xs)
        -- derive Ord
        deriveClass "Ord"
            | [prod] <- ctrs = [publicfun "<=>"
                                          [conpat prod "a", conpat prod "b"]
                                          (ordex (arity prod) 0)]
            | otherwise = [publicfun  "<=>" [parg1, parg2] outercase]
            where
                --* case a1 <=> b1 of { Eq -> case a2 <=> b2 of { ...
                ordex a n
                    | a == n    = vEq
                    | a == n+1  = comp
                    | otherwise = Case CNormal comp [calt1, calt2]
                    where
                        cmp = gvar2 "PreludeBase" "Ord" "<=>"
                        va  = var ("a" ++ show (n+1))
                        vb  = var ("b" ++ show (n+1))
                        comp = nApp (nApp cmp va) vb
                        calt1 = calt vEq (ordex a (n+1))
                        calt2 = calt (var "r") (var "r")
                --*  (C ai, C bi) -> ordex ai bi
                mkeqcase con = calt (ptup peq1 peq2) oex
                    where
                        a = arity con
                        peq1 = conpat con "a"    -- C a1 a2 .. an
                        peq2 = conpat con "b"    -- C b1 b2 .. bn
                        oex  = ordex a 0
                outercase = Case CNormal  defex [alt1, alt2]
                defex     = nApp (nApp (gvar2 "PreludeBase" "Ord" "<=>") oa1) oa2
                oa1       = nApp (gvar "PreludeBase" "constructor") varg1
                oa2       = nApp (gvar "PreludeBase" "constructor") varg2
                alt1      = calt vEq cas
                alt2      = calt (var "x") (var "x")
                cas       = if isEnum then vEq else Case CNormal (vtup varg1 varg2) eqexs
                eqexs     = (map mkeqcase ctrs) ++ [default_]
                default_  = calt (var "_") vEq
        deriveClass "Show"
            | forty.name.base ~ ´^\(,+\)´ = let             -- tuple
                    sex     = Case CNormal (var "r") [(mktupshowalt con)]
                    show    = publicfun "show"     [var "r"]  sex
                    -- showsub = publicfun "showsub"  []          (var "show")
                in [show]
            | otherwise = let
                    sex =   Case CNormal (var "r") (mkshowalts ctrs)
                    subex = Case CNormal (var "r") (mkshowsubalts ctrs)
                    show    = publicfun "show"      [var "r"]  sex
                    showsub = publicfun "showsub"   [var "r"]  subex
                in [show, showsub]
            where
                mkshowalts    constr = map mkshowalt constr
                mkshowsubalts constr = map mkshowsubalt constr
                mkshowalt :: Symbol -> CAltS
                mkshowalt con = calt (conpat con "a") sx
                    where
                        scon = string (con.name.base)
                        sub  = take (arity con) (subvars "a")
                        sx   = joinit scon sub
                        blanked s  = s `mkapp` string " "
                        showit v   = gvar "PreludeText" "showsub" `nApp` v
                        showsv s v = blanked s `mkapp` showit v
                        joinit s [] = s
                        joinit s (v:vs) = joinit (showsv s v) vs
                mkshowsubalt con =
                    let
                        salt = mkshowalt con
                        subx = (string "(" `mkapp` salt.ex) `mkapp` string ")"
                    in if arity con == 0 then salt
                        else salt.{ex=subx}
                mktupshowalt con = calt (conpat con "a") sx where
                    scon = string "("
                    sub  = take (arity con) (subvars "a")
                    sx = joinit scon sub
                    showsv s v d = (s `mkapp` showit v) `mkapp` string d
                    joinit s [] = s `mkapp` string ")"
                    joinit s [v] = showsv s v ")"
                    joinit s (a:b:c) = joinit (showsv s a ", ") (b:c)

        deriveClass "Enum" = [ord, from, succ, pred,
                                eFromThenTo, eFromThen]  -- , eq]
            where
                -- eq      = publicfun "=="    [pvar "a", pvar "b"]  eqex
                ord     = publicfun "ord"   [var "r"]      oex
                from    = publicfun "from"  [var "r"]      fex
                succ    = publicfun "succ"  [var "r"]      sex
                pred    = publicfun "pred"  [var "r"]      pex
                eFromThenTo = publicfun "enumFromThenTo" [parg1, parg2, parg3]
                                eFTTex
                eFromThen = publicfun "enumFromThen" [parg1, parg2]
                                eFTex                                
                -- eqex    = (opEq `nApp`
                --             ((var "<=>" `nApp` var "a") `nApp` var "b")) `nApp`
                --                 pEq
                ctup    = sortBy (comparing Symbol.cid) ctrs
                ctdn    = reverse ctup
                max     = Con {name=cname (head ctdn)}
                min     = Con {name=cname (head ctup)}
                minmax  = Ifte (mkop varg1 opLt varg2) max min
                oex     = nApp (gvar "PreludeBase" "constructor") (var "r")
                fex     = Case CNormal (var "r") (map fromalt ctup ++ [last])
                sex     = Case CNormal (var "r") (mkalts "succ " ctup)
                pex     = Case CNormal (var "r") (mkalts "pred " ctdn)
                last    = calt (var "_") (nApp vError msg)        -- _ -> error ...
                msg     = (string (forty.name.nice g)
                          `mkapp` string ".from ")
                          `mkapp` showit (var "r")                  -- "X" ++ ".from " ++ show r
                fromalt ctr = calt (int (Symbol.cid ctr)) (Con {name=cname ctr})
                mkalts s [x] = [calt (conpat x "_") (nApp vError (string (s ++ show (cname x))))]
                mkalts s (x:y:zs) = calt (conpat x "_") (Con  {name=cname y}) : mkalts s (y:zs)
                mkalts s [] = []
                eFTTex
                    | length ctrs > 1  = nApp (nApp vMap vFrom)
                            (fold nApp vIntEnumFTT 
                                (map (nApp vOrd) [varg1, varg2, varg3]))
                    | otherwise = singleton min
                eFTex   = fold nApp (var "enumFromThenTo") [varg1, varg2, minmax]

        deriveClass "Bounded" = [minval, maxval]
            where
                ctup    = sortBy (comparing Symbol.cid) ctrs
                ctdn    = reverse ctup
                min     = Con {name=cname (head ctup)}
                max     = Con {name=cname (head ctdn)}
                maxval  = publicfun "maxBound" [] max
                minval  = publicfun "minBound" [] min

        deriveClass "Exceptional" =  [
                NatDcl{pos, vis=Public, name="javaClass", 
                    txs = [(ForAll [] (RhoTau [] tapp), [])], 
                    meth = fromMaybe (rawName jt) forty.nativ ++ ".class", 
                    isPure = true, gargs = Nothing,
                    doc = Nothing}]
            where
                tapp = TApp pClass this
                this | RhoTau{tau} <- instrho = tau
                     | otherwise = error ("Cannot derive for non type: " ++ nicer forty g)
                jt = sigmaJT g forty.typ
        deriveClass "JavaType" = deriveClass "Exceptional"
        deriveClass "ArrayElement" = deriveClass "Exceptional"
        deriveClass s = error ("can't deriveClass " ++ s)


deriveDcls :: Position -> QName -> Symbol -> [Symbol] -> RhoT SName -> StG [DefinitionS]
deriveDcls pos clas forty ctrs instrho = do
    g <- getST
    -- E.logmsg TRACE4 pos (text ("derive " ++ QName.nice clas g ++ " for " ++ Symbol.nice forty g))
    let dC = deriveClass pos clas forty ctrs instrho g
    case clas of
        TName ppp ccc | inPrelude ppp g,
                        ccc `elem` ["Enum", "Bounded"] -> if all (0==) (map arity ctrs)
            then stio (dC ccc)
            else do
                let bad = [ c.name.nice g | c <- ctrs, arity c != 0 ]
                E.error pos (msgdoc ("Can't derive " ++ clas.nice g
                    ++ " for " ++ forty.nice g ++ " because "
                    ++ (if length bad == 1 then head bad ++ " is not a nullary constructor"
                        else joined ", " bad ++ " are not nullary constructors")))
                stio []
        TName ppp "JavaType"
            | inPrelude ppp g = return (dC "JavaType")
        TName ppp "ArrayElement"
            | inPrelude ppp g = return (dC "ArrayElement")
        TName ppp "Exceptional" 
            | inPrelude ppp g = if isJust forty.nativ
                then return (dC "Exceptional")
                else do
                    E.error pos (msgdoc ("Can't derive Exceptional for " ++ forty.nicer g
                        ++ ", only native types are allowed. "
                        ++ "(Did you want do derive JavaType?)"))
                    return []
        TName ppp ccc | ccc `elem` derivable = stio (dC ccc)
        _ -> do
            E.error pos (msgdoc ("Can't derive " ++ clas.nice g
                ++ ", only Eq, Ord, Enum, Bounded, Show, FromJSON and ToJSON may be derived."))
            stio []
